さすらいのプログラマ

カレンダークラスのサンプル

Public Sub CreateCalendar()
    Dim nYear As Integer
    Dim nMonth As Integer
    Dim c As CCalendar
    Dim ws As Worksheet
    Dim TargetDate As Date
    Dim row As Long
    Dim column As Long
    Dim BaseColumn As Long
    Dim WeekTitle() As String
    Dim i As Long
    
    nYear = InputBox("対象年月を入力してください")
    
    If nYear < 1900 Or nYear > 2050 Then
        MsgBox "1900年～2050年までが有効です。"
        Exit Sub
    End If
    
    Set c = New CCalendar
    c.Year = nYear
    '社休日の設定
    c.AddUserHoliday 1, 2
    c.AddUserHoliday 1, 3
    c.AddUserHoliday 12, 29
    c.AddUserHoliday 12, 30
    c.AddUserHoliday 12, 31
    
    WeekTitle = Split("日,月,火,水,木,金,土", ",")
    
    Set ws = ActiveSheet
    ws.Cells.Delete
    
    Application.ScreenUpdating = False
    With ws.Cells(1, 1)
        .Value = nYear & "年カレンダー"
        .Font.Name = "ＭＳ Ｐゴシック"
        .Font.Size = 16
        .Font.Bold = True
    End With
    
    TargetDate = nYear & "/1/1"
    row = 2                            '開始行
    BaseColumn = 1
    column = Weekday(TargetDate) + BaseColumn
    nMonth = 0
    With ws
        Do While Year(TargetDate) = nYear
            If Month(TargetDate) <> nMonth Then
                row = row + 1
                nMonth = Month(TargetDate)
                With .Cells(row, 1)
                    .Value = nMonth & "月"
                    With .Font
                        .Size = 14
                        .Bold = True
                    End With
                End With
                row = row + 1
                For i = LBound(WeekTitle) To UBound(WeekTitle)
                    SetBorder .Cells(row, BaseColumn + vbSunday).Offset(0, i - LBound(WeekTitle))
                    With .Cells(row, BaseColumn + vbSunday).Offset(0, i - LBound(WeekTitle))
                        .Value = WeekTitle(i - LBound(WeekTitle))
                        .Interior.Color = RGB(128, 128, 128)
                        .HorizontalAlignment = xlHAlignCenter
                    End With
                Next i
                row = row + 1
            End If
            SetBorder .Cells(row, column)
            With .Cells(row, column)
                .Value = Day(TargetDate)
                .Font.ColorIndex = xlAutomatic   '自動？
                .Interior.ColorIndex = xlColorIndexNone
                If c.IsSaturday(Month(TargetDate), Day(TargetDate)) Then
                    '.Font.Color = RGB(0, 0, 255)
                    .Interior.Color = RGB(128, 128, 255)
                End If
                If c.IsSunday(Month(TargetDate), Day(TargetDate)) Then
                    '.Font.Color = RGB(0, 255, 0)
                    .Interior.Color = RGB(255, 128, 128)
                End If
                'If c.IsHoliday(Month(TargetDate), Day(TargetDate)) Then
                If c.IsWorkingHoliday(Month(TargetDate), Day(TargetDate)) Then
                    .Font.Color = RGB(255, 0, 0)
                    .Interior.Color = RGB(255, 128, 128)
                End If
            End With
            column = column + 1
            If column > vbSaturday + 1 Then
                row = row + 1
                column = vbSunday + BaseColumn
            End If
            TargetDate = TargetDate + 1
        Loop
    End With
End Sub

Private Sub SetBorder(TargetRange As Range)
    With TargetRange
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
End Sub